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S FACILITY: RPGII SUPPORT 

ie ABSTRACT 

0036 i This routine supports the RPG UDATE, UDAY, UMONTH and UYEAR 
0037 i special words. 

0038 i 

0039 i 

Bees ENVIRONMENT: Vax-11 User Mode 

Be AUTHOR: Debess Grabazs, CREATION DATE: 25-JAN-1983 

0044 i MODIFIED BY: 

0045 i 

004 i 1-001 - Original. DG 25-JAN-1983 

9944 i 1-002 = Take out ZASCID - was making code unsharable. DG 11-Jul-1983 
0049 

0050 ' <BLF /PAGE> 
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ort alee UDAY, UMONTH, UYEAR special word 1b-sep=1 
clarations 14 


RSBTTL Declarations’ 
. * PROLOGUE FILE: 


REQUIRE ‘RTLIN:RPGPROLOG'; 


14 
' LINKAGES 

: NONE 
1+ 


TABLE OF CONTENTS: 


FORWARD ROUTINE 


RPGSUDATE : NOVALUE ; 


1+ 


i INCLUDE FILES 
i NONE 


‘+ 
i MACROS 
NONE 


'¢ 
! EQUATED SYMBOLS 
: NONE 


1+ 


: EXTERNAL REFERENCES 

EXTERNAL ROUTINE 
COB$ 

EXTERNAL LITERAL 


RPGS_FATINTERR, 
RPG$_INVUDATE; 


980: 


es, PSECTs 
ges and LI 


4, -74 
RPGRTLS §R C RPGUDATE .83 1 


Get the current date 
Stop execution via signalling 
Convert string to upper case 


Fatal internal error 
Incorrectly specified date 


jolelelelea) 


WAAL NA AIO POPPI PUNIPUNO NYPD 2 SO OS OOO 


tated stalatatataadababaiaiabad abated iababaabababaiaiabaabeababababababababababababababababuababaDababaial 


Dr & EEE EEE EW 
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1 ZSBTTL ‘RPGSUDATE - suepert UDATE, UDAY, UMONTH, UYEAR special words’ 
GLOBAL ROUTINE RPGSUDATE ( 
' Current day 


MONTH, ' Current month 
YEAR ' Current year 
): NOVALUE= 


+ 
+ 


FUNCTIONAL DESCRIPTION 
This routine translates the logical name RPGSUDATE. If 
the logical translates, the date specified in the logical 
name is used; otherwise the current system date is used. 
The format of the date in RPGSUDATE is dd-mmm-yyyy. 
Two character strings representing the day, numeric month 
and last two digits of the year are moved into the appropriate 
return parameters. 
This routine is called when an RPGII program has any of the 
special words UDATE, UDAY, UMONTH, or UYEAR in it. 

CALLING SEQUENCE: 
CALL RPGSUDATE (day.wt.r, month.wt.r, year.wt.r) 

FORMAL PARAMETERS: 


day address of 2 character string to receive 
current day of the mont 


month address of 2 character string to receive 
current month number 


year address of 2 character string to receive 
current year 
IMPLICIT INPUTS: 
RPGSUDATE - logical name which may have the date 


specified in it 
IMPLICIT OUTPUTS: 
NONE 
COMPLETION CODES: 
NONE 
SIDE EFFECTS: 
Errors will be signalled oy Hye este specified in RPGSUDATE 


is incorrectl speci tied 6 ere is an error in the 
the logical 


SOOGDOGDOOOS OO 0000 OOO O09 09 69 09 09 09 09 09 09 09 SI NIN NINININSINNIOA AAA OOO 


DONA EWN 0 OONOAUE WIN SO OO NAME WIN $$ OS OONA UE WN OOO NAUES WIN SO OONAULS WI 


translation o 


me ee ee a eB ee ee ed ed od dd od od ed 
ee ee te ee ee ee ee ee te ee ee eee ee te te te te te te te te ee ee ee 
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—) se ss = = 
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1-00 RPGSUDATE = Support UDATE, UDAY, UMONTP, UYEA 
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d 18-Sep-1986 02:19:50  VAX=11 BLiss-32 v4.0-74 p 4 
ereent 88s PEih2:38 HANG AT Bkisgab2 Mee O-28s 29° (33 
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gow 
160 2 1 !<BLF/PAGE> 
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, 
RP ATE Support UDATE, UDAY, UMONTH, UYEAR special word 16-Sep-1984 :19: -32 
et RPESUDATE = Support UDATE, UDAY, UMONTH, UYEAR 1a-8ep-19 4 Oe: M2: Aas ate Sat SRbeubAte 0351 (4 


mow 
ao 


16 
BEGIN 
LOCAL 
DASH_PTR Pointer to Ist dash 
DEST-DESC: BLOCK (8, BYTE), Local desc for call to $TRWLOG 
hy Size of year part 


Pointer past end of logical name string 
Local desc for call to STRNLOG 
Indicator of valid month 

Local string for uppercase month 


ND_PTR 

LOG-DESC: BLOCK (8, BYTE) 
MONTH_FOUND: BYTE ing TIAL (0), 
MONTH-TEXT: VECTOR C3, BYTEJ, 


NAME __LENGTH, Length of logical name string 
NAME TEXT: VECTOR CLNMSC_NAMLENGTH, BYTE), Local string for logical name 
RET_STATUS; 

BIND 


MONTHNAME = UPLIT( 
* JANF EBMARAPRMAY JUNJULAUGSEPOCTNOVDEC'), 


Month names 


MONTHNUM = tte 
*010203040506070809101112"), 


Month numbers 


— 
APAVESSAVSARAN-SSRUSALG 


ea ke ke ed ad ak kd od td td td 2 = dt I I 
DONA MNE WN 0 ODNA VUE WP 0 OONOY FWP" OOONOUEWw 


Return status 
4 
4 
4 
” 
4 P_DASH = UPLIT (‘="), 
4 P_ZERO = UPLIT ('0'); 
86 4 
87 34 '¢ 
88 4 ! 
34 $2 Initialize descriptors for call to S$STRNLOG. 
9 33 te 
36 5 DEST_DESCCDSC$W_LENGTH] = LNMSC_NAMLENGTH; 
9 $3 DEST_DESC psCsB CLASS) = DSCSK_CLASS_S; 
94 5 DEST_DESCCDSC$B_DTYPE] = DSCSK_DTYPE_T; 
32 $2 DEST_DESCCDSCSA_POINTER) = NAME_TEXT; 
97 25 LOG_DESCCDSCS$W_LENGTH] = ZXCHARCOUNT ("RPGSUDATE'); 
98 25 LOG_DESC 443 eS? = DSCSK_CLASS_S; 
199 $60 LOG_DESCCDSCSB_DTYPE] = DSCSK_DTYPE_T; 
soe ] LOG_DESCCDSC$A_POINTER) = UPLTT (*RPGSUDATE"); 
4 8 '¢ 
0 64 ! 
Be 66 Try to translate the logical name RPGSUDATE. 
6 Hed 
0 


RET_STATUS = $TRNLOG (LOGNAM = LOG_DESC, RSLLEN = NAME_LENGTH, RSLBUF = DEST_DESC); 
IF .RET_STATUS EQL SS$_NORMAL 

THEN 

'¢ 
' 

: Logical name translated - use date specified ('dd-mmm-yyyy'). 


CODOOCCCOOOCCOCOOCOOCOCOOSO OOOO OOOCCOOOOOOOOOOOOOoOO 


oooooo 

POPRIPOPIPONIPONPONINONY 
SAN NOO 
CONOUSWIN OO 


le 
BEGIN ' Logical translated 


IF CHSFAIL (DASH_PTR = CHSFIND_CH ( ' Find first dash in date | 
Se ' Should be in 2nd or 3rd 
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UDATE = Support UDATE, UDAY, UMONTH, UYEAR 12-808- 1 9be ¢: 


04:26 RPGRTL.SRCJRPGUDATE .832;1 
gPES] PESCCOSCSA_POINTERI#1. ! position only 


THEN 
gg tIBSSTOP (RPGS_INVUDATE) 


'¢ 


! 
Found first dash, now process day part of date. 


le 
BEGIN ! Fourd Ist dash 


LOCAL 
DEST2_DESC: BLOCK (8, BYTEJ; ! Local desc for call to STRSUPCASE 


— (.DASH_PTR, .DEST_DESCCDSCSA_POINTER]) EQL %CHARCOUNT (‘'d') 


+ 

! 

! Day ¢art is onty one character, 
sO must pad with a leading zero. 


lo 

BEGIN 

CHSMOVE (1, P_ZERO, .DAY); 

CHSMOVE (1, .BEST_OESCCOSCSA_POINTER], .DAY+1); 


END 
ELSE 
_, CHSMOVE (2, .DEST_DESCCDSCSA_POINTER], .DAY); 


i 
' Process year part of date. 
DASH_PTR still points to Ist dash (-mmm-yyyy). 


leo 
IF CHSEQL (1, P_DASH, 1, .DASH_PTR+4) 
THEN 
‘+ 
i] 
i Found second dash, now determine how 
} many characters in year part of date. 


le 
BEGIN ! Found 2nd dash 


END_PTR = .DEST_DESCCDSCSA_POINTER] + .NAME_LENGTH; 
DIFF = CHSDIFF T.END PTR, -DASH_PTR+5); 
1F DIFF GTR XCHARCOONT ("y') 


Correctly specified year part (at least 2 chars). 


le 
CHSMOVE (2, .END_PTR-2, . YEAR) 


) 
H 5 
RP ATE Support UDATE, UDAY, UMONTH, UYEAR special word 16-Sep-1984 02:19:50 AX-11 Bliss-32 V4.0-74 Pa 7 
Peay RPEBUDATE = Support UDATE, UDAY, UMONTH UYEAR 127808718 4 96: b2:38 RPGRTL. RCIRPGUDATE .B3 31 - (4) | 
3 76 7 LSE | 
3 a 3 ; IF .DIFF EQL ZCHARCOUNT ('y') 
: 278 THEN 
; 79 40 6 BEGIN 
epee , | 
; ¢ : 6 i Year part is only one character, 
: 28 44 6 ! so must pad with leading zero. | 
Be RY | 
: 286 “3 8 CHSMOVE (1, P_ZERO, .YEAR); 
: 287 48 6 CHSMOVE (1, .END_PfR-1, .YEAR+1); 
: 289 50 END 
: 290 $ 51 e LSE 
; 3) 8 26 5 LIBSSTOP (RPGS$_INVUDATE); 
3 38 0354 ; END ! Found 2nd dash | 
: 295 0356 rs LSE 
; 96 035 4 LIBSSTOP (RPG$_INVUDATE); 
Ro Re . 
: 299 0360 4 i 
; 500 0361 4 ! Process month part of date. 
: 301 6366 4 ! DASH_PTR still points to ist dash (-mmm-yyyy). 
: 308 Osea 
; 04 0365 4 pest Be SEED Sc oy _LEMeTH) = ZCHARCOUNT ('mmm'); | 
3 05 0 4 DEST_DESCLDOSCS$A_ POINTER] =. H_PTR + 1; 
; 06 84 4 DEST2_DESC DSC$O_LENGTH = ZCHARTOUNT ('mmm'); 
3 07 0368 4 DEST2_DESCLDSCS$B_CLASS] = DSCSK_CLASS_S; 
3 08 Bee? 4 DEST2_DESCLDSCSB_DTYPE) = DSCSK_DTYPE_T; 
5 09 a3n 4 DEST2-DESCEDSCSA_POINTER] = MONTH TEXT; 
; i} 0 ie: ? Change month specified to uppercase for matching. 
; 15 0374 ? if NOT (STRSUPCASE (DEST2_DESC, DEST_DESC)) 
; 15 0376 4 LIBSSTOP (RPGS$_FATINTERR); 
; 13 ie 4 INCR I FROM 0 TO 11 DO 
; + 0380 BEGIN | 
: 320 ; 1 i 
s $f 0 § ' Search for character match in table | 
3 38 3 and convert to numerical equivalent. 
> 324 85 ie 
3 25 HH acai (3, CHSPTR (MONTHNAME, .1*3), 3, .DEST2_DESCCDSCSA_POINTER)) 
: ; i é BEGIN | 
: 329 é CHSMOVE (2, CHSPTR (MONTHNUM, .1*2), .MONTH); | 
; 91 6 MONTH FOUND = 1; 
§ 1 3 6 EXITLOOP; 
3 2 93 6 
| 
| 
| 


3 
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*+msaeriieieinrs a 


5 
Support UDATE, UDAY, UMONTH, UYEAR s ae word 14. -Sep-1984 99:19:30 AX-11 Bi jegece V4.0-74 Page 


| 
DATE - Support “UDATE, DAY, UMONTH, UYEAR 14-Sep-1984 RPGRTL.S RPGUDATE .B832;1 (4) | 
94 END; | 
33 8 | 
96 4 END; 
97 4 '¢ 
3 4 ! | 
4 ! Make sure a match was found. 
400 4 ! 
401 4 Hod 
4 3 4 IF NOT .MONTH_FOUND 
4 4 N 
, $ 4 LIBSSTOP (RPGS$_INVUDATE); | 
496 END; ! Found Ist dash 
408 END ' Logical *ranslated 
0409 ELSE . 
0410 '¢ 
04611 | 
b21§ ! Logical name did not translate - use current system date. 
041 : 
0414 t= 
0415 BEGIN 
Bs18 
041 IF .RET_STATUS EQL SS$_NOTRAN 
0418 THE 
0419 4 BEGIN 
pes 4 
0421 4 COBSACC_DATE (DEST DESC); ' Returns "Tyeeee 
04 g 4 CHSMOVE” (XCHARCOUNT ( "yy! , «DEST_DESCCDSCSA_POINTERJ, .YEAR); 
04 4 CHSMOVE (ZCHARCOUNT (ot) -DEST_DESCLDSCSA_POINTERJ+2, -MONTH); 
be : : CHSMOVE (ZCHARCOUNT ('dd'), .DEST_DESCCDSCSA_POINTERIJ+4, .DAY); 
0426 4 END 
8 7 LSE 
8 LIBSSTOP (.RET_STATUS); 
0429 
0430 2 END; 
0431 2 
0432 1 END; 


-TITLE RPGSUDATE Support UDATE, UDAY, UMONTH, UYEAR sp 
; ecial word 
-IDENT \1-002\ 


-PSECT _RPGSCODE,NOWRT, SHR, PIC,2 


59 41 4D 52 50 41 36 41 4D 42 45 46 4E 41 4A Q0000 P.AAA: .ASCII \JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC\ 3 
54 43 4F 50 45 53 47 55 41 is 22 rr 4E 2? ri aoi¢ 3 
30 37 30 36 30 35 39 + 3 ; 3 2 p 1 6 4 P.AAB: .ASCII \010203040506070809101112\ 3 
-_ - 1 0 0033 ; 

6 D f P.AAC: .ASCII \-\ + + ~ > : 

3 40 P.AAD: .ASCII \O\< 3 

00 00 00 45 54 41 44 55 4 & 44 P.AAE: .ASCII \RPGSUDATE\<0><0><0> ; 


MONTHNAME = P.AAA 


RP ATE Support UDATE, UDAY, UMONTH, UYEAR s ec tot ttt? 1b-se Sep-1984 19:5 AX-11 Bliss-32 v4. P m7 
rP8 Oo" RPESUDATE - Support UDATE, UDAY, UMONTH, Sep-1984 9¢: 04:2 RPGRTL.SRC RPcuDAiE .68 B32;1 ~— S 
MONT HNUM= P.AAB 
P_DASH= BAC 
P-ZERO= 
.EXTRN cosate. DATE LIBSSTOP Psc 
SEXTRN STRSUPCASE, RPG$_FATINTERR ==: 
SEXTRN RPGS$_INVUDATE, SYSSTRNLOG on 
O1FC 000 .ENTRY RPGS DATE. save R2,R3,R4,R5,R6,R7,RB : 0163 
58 000000006 8F D0 0000 MOVL 4#RPG +f ; seg 
Fs AF 9E 999 MOVAB FEROL a : $$! 
26 000000 06 00 9E 0000D VAB LIBSsTOp, R6 : 
E FEE ce 3 O14 MOVAB <=288(SP). SP : 
9 19 CLRB MONTH FOUN + 0224 
F8 AD OIOEOOFF 8F po O18 MOVL  #1769%975, DEST_DESC + 0253 
FC OAD 10 AE 9E 0002 MOVAB NAME TEXT. DEST “DESC +4 > 0256 
FO AD 010E0009_~=s BFF po 00 8 MOVL 17694729. LOG DESC : 0258 $$! 
F4 OAD 04 A? 9E 000 MOVAB P.AAE, LOG_DEST+4 > 0261 
7E 7€ 00035 CLRQ = = SP) : 0268 
7E 04 00037 LRL ss = (SP : 
F8 AD 9F 00039 PUSHAB DEST_DESC : 
10 AE 9F 0003C PUSHAB NAME~LENGTH : 
FO AD OF O003F PUSHAB LOG_BESC ; 
000000006 00 6 FB 0042 CALLS rr “SYSS$TRNLOG ; 
01 0 D1 0004 CMPL = RET_STATUS, #1 + 0269 
03 13 0004C BEQL ‘§ ; 
OOBA 31 0004E BRW 15$ : 
52 FC AD p60 00051 1$: MOVL DEST 2 SC+4 3? + 0280 
01 A2 02 20 A 00055 LOCC = #45 : 0278 
2 12 0005A BNEQ 28° : 
31 D4 0005¢ CLRL sR : 
53 1 09 0005E 2$ MOVL 1, DASH_PTR ; 
05 12 00061 BNEG 4$ : 0281 
58 pp 90065 3$: PUSHL Rg : 0283 
00¢ 006 BRW 17$ F 
50 01 A2 9E 00068 43: MOVAB =: 1(R2) > 0295 
50 53 D1 0006C CMPL DASH brre RO ; 
OF I2 0006F BNEQ 5$ F 
04 BC 67 9 90071 MOVB P ZERO aDAY : 6305 
0 04 ag DO te MOVL DAY : 
01 AO 62 90 0007 MOVB = (R25, RD (ROD + 0306 
04 11 00070 BRB ag : 9295 
04 BC 62 80 OO7F 5$: MOVW = (R2) : 0310 
04 AS FC 4 91 o088 és: CPB PD Ague OA DASH. PTR) : 0317 
50 52 gf G 09 A ADDL3 NAME_LENGTH, R2 END PTR : 0327 
51 5 53 C3 0008 SUBL3 DASH~PTR, END_PTR, : 0328 
51 05 ¢ 009 SUBL2 #5, DIFF. ; 
01 1D 9 CMPL fe, #1 : 0329 
07 15 00098 BLEG F 
0c BC FE AO 80 9A MOVW 5g (END_PTR), @YEAR > 0336 
16 1 OF BRB : 
OF 12 OOOA1 7$ BNEQ 8$ ; 0338 
0c eC 67 9 0 a3 MOVB OP ZERO, 1 BYEAR : 0347 
1 Oc AC p A MOVL we ; 
01 «AI FF Ag A MOVB ttle Arr). 1(R1) > 0348 
Q 1 B BRB : 0 38 
8 DD 000B2 8$ PUSHL 8 : 0 


Kk 5 
R ATE Support UDATE, UDAY, UMONTH, UYEAR special word 16-Sep-1984 02:19: AX-11 Bliss-32 V4.0-74 P 1 
et RPERODATE Support UDATE, UDAY, UMONTH, UYEAR 12-80-1382 96: b2:38 APGRTL’ SRE SRPGUDATS 3551 o- (as 
66 F B4 CALLS #1, LIBS$STOP ; 
43 AD a 60 df ver, MOVAB 1(R3) ; BF oes +4 : 362 
08 AE 01060098 BF 06 cD MOVL 115334795 Maat: DESC : 367 
C AE 04 AE 9E 000C VAB_ MONTH_TEXf, DEST2_DESC+4 + 0370 
FB AD i CD PUSHAB DEST_BESC + 0374 
OC AE OF 09 PUSHAB DEST2_DESC ; 
000000006 00 4] 6 D5 CALLS . ; G UPCASE 3 
000000006 8F ODD S900 PUSHL #RPGS$_FATINTERR : 0376 
6 } fe BE 108 CALLS ‘. LIB$sToP ; 0386 
50 54 ; c3 itt 19§: MULL . 1, RO ; 
Oc BE CO A740 03 $9 oars CMEC 3, MONTHNAMECROJ, @DEST2_DESC+4 ; 
08 Bf E4 A744 26 000F MOVW § MONTHNUMCI], @MONTH + 0390 
5 01 0 000r8 MOVB #1, MONTH_F OUND : 0391 
4 11 OOFE BRB 13 : 0388 
E4 54 0B F3 91 128: AOBLEQ #11, I, 11$ : 0378 
03 5 &8 0104 13$:  BLBS § MONTH_FOUND, 14$ + 0402 
FF59 31 00107 BRW 3$ ; 
04 O010A 148: RET + 0404 
00000629 =F 50 01 00108 15$:  CMPL  RET_STATUS, #1577 + 0417 
1D 12 0011 BNEQ 16$ : 
F8 AD OF 00114 PUSHAB DEST_DESC + 0421 
000000006 90 01 FB 00117 CALLS #1, COBSACC_DATE ; 
0 FC AD 0bO O11 MOVL  DEST_DESC+4> RO t 0422 
oc BC 60 BO 001 MOVW  (RO)> @YEAR : 
08 BC 02 Ad BO 00126 MOVW 2(ROS, @MONTH + 0423 
04 BC 04 Aad B80 00128 MOVW 4(RO), aDAY + 0424 
04 00130 RE : 0417 
50 DD 00131 16$: | PUSHL RET_STATUS : 0428 
66 01 FB 00133 17$: CALLS #1,"LIBS$STOP ; 
04 001 RET + 0432 
; Routine Size: 311 bytes, Routine Base: _RPGSCODE + 0050 
F 372 0433 1 
: 37 0434 0 END ELUDOM 
; PSECT SUMMARY 
; Name Bytes Attributes 
:  _RPGSCODE 391 NOVEC,NOWRT, RD, EXE, SHR, LCL, REL, CON, PIC,ALIGN(2) 


; Library Statistics 


ED) re rs et ee ee HMMM MMMM MMMM MMMM MMMM AIAIAIOMOOOMOOOM 
SDK DK DK DK DK DK DK DE DK DK DK DK DK DK DK DK DE OE OE ht ht tt 4 4 4 I 


lle el, BOOOOS 2 2k Wk WK PE PK PE PK WK WK WK WK OK PK OK OK OK KK 


a++4<-DOO0O 


RP ATE Support ATE, UDAY, UMONTH, UYEAR special word 1b-se Sep-19 AX-11 Bliss-32 V4.0-7 

HF RPGBUDAT = Support “UDATE, UDAY, TH, UYEAR 1 $007 3b 96:02 £38 RPGRTL.SRC RPGUDATE .83 31 
; socceees Symbols oooeee~ Pages Processing 

: File Total Loaded Percent Mapped Time 

: _$255$DUA SYSLIBISTARLET 32: 9776 1 581 0:01.0 

eee ASB tapente ops aRPGL Tec $2;1 ee j 0 5 00:00:1 


COMMAND QUALIFIERS 


BLISS/CHECK=(FIELD, INITIAL OPTIMIZE) /NOTRACE/LIS=LIS$:RPGUDATE/O8J=0BJ$:RPGUDATE MSRC$:RPGUDATE/UPDATE=(ENH$:RPGUDATE ) 


311 08°68 ; 80 data bytes 
Eleesed Tine: 09: a 
Lines/CPU Min: 059 


[ce Ae Higa 14044 
aoaeey Used: 130 pages 
Compilation Complete 


SE EQUIPMENT CORPORATION 


0 


NTIAL -AND PROPRIETARY 


